PD ROM 1/PD ROM Volume I - Macintosh Software from BMUG (1988).iso/Games/Puzzles/WordFind/placeword

Text File | 1987-11-14 | 6.9 KB | 329 lines | [TEXT/PJMM]

UNIT placepuzzle;
INTERFACE
    USES
        stringf;
    CONST
        MAXX = 30;
        MAXY = 30;
    TYPE
        cell = RECORD
                ch : char;
                boldf : boolean;
            END;
        cmat = ARRAY[1..MAXX, 1..MAXY] OF cell;
    VAR
        XMAX : integer;
        YMAX : integer;
        puzzle : cmat;
    FUNCTION randnum (x : integer) : integer;
    FUNCTION rightlen (word : STRING) : boolean;
    FUNCTION placerandom (word : STRING) : boolean;
    FUNCTION placeanyplace (word : STRING) : boolean;
IMPLEMENTATION
    TYPE
        location = RECORD
                x : integer;
                y : integer;
            END;

        crose = (north, south, east, west, northeast, northwest, southeast, southwest);
        compass = SET OF crose;
        randrec = RECORD
                xp, yp : integer;
                dir : crose;
                incx, incy : integer; {used to check fit}
            END;
    VAR
        rrec : randrec;
    FUNCTION randnum;
{ returns a random number between x and 1 }
        VAR
            y, z : real;
    BEGIN
        y := abs(Random);
        z := (y / 32768.0);
        randnum := integer(trunc(x * z)) + 1;
    END;
    PROCEDURE getinc (VAR x, y : integer;
                                    d : crose);
    BEGIN
        CASE d OF
            north, south :
                BEGIN
                    y := 1;
                    x := 0;
                END;
            east, west :
                BEGIN
                    y := 0;
                    x := 1;
                END;
            northeast, southwest :
                BEGIN
                    x := -1;
                    y := 1;
                END;
            northwest, southeast :
                BEGIN
                    x := 1;
                    y := 1;
                END;
        END;
    END;
    PROCEDURE getrand (VAR r : randrec);
        VAR
            xi, yi : integer;
    BEGIN
        r.xp := randnum(XMAX);
        r.yp := randnum(YMAX);
        CASE randnum(8) OF
            1 :
                r.dir := north;
            2 :
                r.dir := south;
            3 :
                r.dir := east;
            4 :
                r.dir := west;
            5 :
                r.dir := northeast;
            6 :
                r.dir := northwest;
            7 :
                r.dir := southeast;
            8 :
                r.dir := southwest;
        END;
        getinc(xi, yi, r.dir);
        r.incx := xi;
        r.incy := yi;
    END;
    FUNCTION placerandom;

        VAR
            backwords : SET OF crose;
            i, j, k, x, y : integer;
            len : integer;
            ok : boolean;
    BEGIN
        len := length(word);
        backwords := [east, north, northeast, southeast];
        ok := true;
        getrand(rrec);
        IF rrec.dir IN backwords THEN
            wreverse(word);
        CASE rrec.dir OF
            north, south :
                BEGIN
                    IF YMAX - rrec.yp + 1 < len THEN
                        ok := false;
                END;
            east, west :
                BEGIN
                    IF XMAX - rrec.xp + 1 < len THEN
                        ok := false;
                END;
            northwest, southeast :
                BEGIN
                    IF (XMAX - rrec.xp + 1 < len) OR (YMAX - rrec.yp + 1 < len) THEN
                        ok := false;
                END;
            northeast, southwest :
                BEGIN
                    IF (rrec.xp < len) OR (YMAX - rrec.yp + 1 < len) THEN
                        ok := false;
                END;
        END;
        IF ok = true THEN
{it has now passed the first test}
            BEGIN
                x := rrec.xp; (* set up the pointers *)
                y := rrec.yp;
                i := 1;
                WHILE ((puzzle[x, y].ch = ' ') OR (puzzle[x, y].ch = word[i])) AND (i < len) DO
                    BEGIN
                        x := x + rrec.incx;
                        y := y + rrec.incy;
                        i := i + 1;
                    END;
                IF (i = len) AND ((puzzle[x, y].ch = word[i]) OR (puzzle[x, y].ch = ' ')) THEN
            (* we made it!!! The word fits into the puzzle;  put it in!!!*)
                    BEGIN
                        ok := true;
                        x := rrec.xp;
                        y := rrec.yp;
                        FOR i := 1 TO len DO
                            BEGIN
                                puzzle[x, y].ch := word[i];
                                puzzle[x, y].boldf := true;
                                x := x + rrec.incx;
                                y := y + rrec.incy;
                            END;
                    END
                ELSE
                    ok := false;
            END;
        placerandom := ok;
    END;

    FUNCTION rightlen; (* will the word fit on the screen?*)
    BEGIN
        IF (length(word) > XMAX) AND (length(word) > YMAX) THEN
            rightlen := false
        ELSE
            rightlen := true;
    END;
{}


{This routine will do anything to get a word into the puzzle}

    FUNCTION placeanyplace; (* get it in there anyway you have to*)
        CONST
            NUMDIR = 8;
        LABEL
            100;
        VAR
            pword : STRING;
            ok : boolean; (*this is used to get us out of the loop*)
            xi, yi, lcount, len, x, y : integer;
            incx, incy : integer;
            backwords : SET OF crose;
            dirset, dirarray : ARRAY[1..NUMDIR] OF integer;
            dirptr : integer;
            whichway : crose;
            dircount : integer;
        PROCEDURE setrandlist;
            VAR
                i, j : integer;
                rdir : integer;
                d : crose;
                num : integer;
        BEGIN
            FOR i := 1 TO NUMDIR DO { create array of possible values }
                dirset[i] := i;
            FOR i := 1 TO NUMDIR DO { pick one at random and assign it to a slot in dirarray}
                BEGIN
                    IF i < NUMDIR THEN
                        rdir := randnum(NUMDIR - i + 1)
                    ELSE
                        rdir := 1;
                    dirarray[i] := dirset[rdir];
                    IF i <> NUMDIR THEN
                        FOR j := rdir TO NUMDIR - i DO
                            dirset[j] := dirset[j + 1];
                END;
            dirptr := 1;
        END;
        FUNCTION getdir : crose;
            VAR
                dircnt, d : crose;
                i : integer;
        BEGIN
            IF dirarray[dirptr] = 1 THEN
                getdir := north
            ELSE
                BEGIN
                    d := north;
                    FOR i := 1 TO dirarray[dirptr] - 1 DO
                        d := succ(d);  (* bump up direction*)
                    getdir := d;
                END;
            IF dirptr < NUMDIR THEN
                dirptr := dirptr + 1;
        END;

    BEGIN
        setrandlist;
        backwords := [east, north, northeast, southeast];
        dircount := 1;
        whichway := getdir;
        len := length(word);
        xi := 1;
        yi := 1;
        REPEAT
            ok := true;
            pword := word;
            IF whichway IN backwords THEN
                wreverse(pword);
            getinc(incx, incy, whichway);
(**)
(*Will this fit in the spot we have chosen?*)
(**)
            CASE whichway OF
                north, south :
                    BEGIN
                        IF YMAX - yi + 1 < len THEN
                            ok := false;
                    END;
                east, west :
                    BEGIN
                        IF XMAX - xi + 1 < len THEN
                            ok := false;
                    END;
                northwest, southeast :
                    BEGIN
                        IF (XMAX - xi + 1 < len) OR (YMAX - yi + 1 < len) THEN
                            ok := false;
                    END;
                northeast, southwest :
                    BEGIN
                        IF (xi < len) OR (YMAX - yi + 1 < len) THEN
                            ok := false;
                    END;
            END; {end case}
            IF ok = true THEN
{it has now passed the first test}
{there is room for it}
                BEGIN
                    x := xi; (* set up the pointers *)
                    y := yi;
                    lcount := 1;
                    WHILE ((puzzle[x, y].ch = ' ') OR (puzzle[x, y].ch = word[lcount])) AND (lcount < len) DO
                        BEGIN
                            x := x + incx;
                            y := y + incy;
                            lcount := lcount + 1;
                        END;
                    IF ((lcount = len) AND (puzzle[x, y].ch = word[lcount])) OR ((lcount = len) AND (puzzle[x, y].ch = ' ')) THEN
            (* we made it!!! The word fits into the puzzle;  put it in!!!*)
                        BEGIN
                            ok := true;
                            x := xi;
                            y := yi;
                            FOR lcount := 1 TO len DO
                                BEGIN
                                    puzzle[x, y].ch := word[lcount];
                                    puzzle[x, y].boldf := true;
                                    x := x + incx;
                                    y := y + incy;
                                END; {end for}
                        END {end if}
 { didn't fit in the space}
                    ELSE
                        ok := false;
                END
            ELSE
                ok := false;

            IF (ok = false) THEN
                IF xi = XMAX THEN
                    IF yi <> YMAX THEN {are we at the end of a line}
                        BEGIN
                            xi := 1; { move to the beginning}
                            yi := yi + 1; {and bump up y}
                        END
                    ELSE IF dircount <> NUMDIR THEN
                        BEGIN
                            whichway := getdir;
                            dircount := dircount + 1;
                        END
                    ELSE
                        GOTO 100 {get out of here we have failed}
                ELSE IF (ok = false) AND (xi < XMAX) THEN
                    xi := xi + 1;
        UNTIL (ok = true);
100 :
        placeanyplace := ok;
    END;
END.